home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SAMPLES / SORTERS.S < prev   
Encoding:
Text File  |  1993-05-13  |  5.7 KB  |  165 lines
  1. ;;; Quicksort, heap sort, insertion sort, and remove-duplicates for vectors.
  2. ;;; This was hacked from Bob Nix's code. 
  3. ;;; Heap sort was written from scratch. It is stable.
  4. ;;; Olin Shivers (shivers@cs.cmu.edu) 2/89
  5. ;;; 
  6. ;;; This must be compiled with macro support from the Yale loop package.
  7.  
  8. ;;; quicksort!
  9. ;;; ===============
  10. ;;; Hoare's QuickSort for vectors.
  11.  
  12. (define (quicksort! v obj-<)
  13.   (labels (((qsort v obj-< start end)
  14.         (if (> (- end start) 10)
  15.         (let ((middle (quicksort!:partition v start end obj-<)))
  16.           (cond ((< (- middle start) (- end middle))
  17.              (qsort v obj-< (+ 1 middle) end)
  18.              (qsort v obj-< start (- middle 1)))
  19.             (t
  20.              (qsort v obj-< start (- middle 1))
  21.              (qsort v obj-< (+ 1 middle) end)))))))
  22.     (qsort v obj-< 0 (- (vector-length v) 1))
  23.     (insertion-sort! v obj-<)))
  24.  
  25. (define (quicksort!:partition v start end obj-<)
  26.     (loop (initial (middle (fixnum-ashr (+ start end) 1)) ; bummed /2
  27.                    (value nil)
  28.                    (l start)
  29.                    (r (+ 1 end)))
  30.       ;; Pick the median of v_start v_middle and v_end for the comparison
  31.       ;; key: put it in v_start.
  32.           (before (if (obj-< (vref v start) (vref v middle))
  33.               (if (not (obj-< (vref v middle) (vref v end)))
  34.               (if (obj-< (vref v start) (vref v end))
  35.                   (set! middle end)
  36.                   (set! middle start)))
  37.               (if (obj-< (vref v start) (vref v end))
  38.               (set! middle start)
  39.               (if (obj-< (vref v middle) (vref v end))
  40.                   (set! middle end))))
  41.           (set! value (vref v middle))
  42.           (set! (vref v middle) (vref v start))
  43.           (set! (vref v start) value))
  44.       ;; Skip past left and right elts on the correct side of the partition
  45.       (next (l (loop (incr l in l)
  46.              (while (obj-< (vref v l) value))
  47.              (result l)))
  48.         (r (loop (decr r in r)
  49.              (while (obj-< value (vref v r)))
  50.              (result r))))
  51.           (while (< l r))
  52.       ;; Swap v_l and v_r
  53.           (do (set! (vref v l) (swap (vref v r) (vref v l))))
  54.       ;; Swap v_start and v_r
  55.           (after (set! (vref v start) (swap (vref v r) (vref v start))))
  56.           (result r)))
  57.  
  58.  
  59. ;;; insertion-sort!
  60. ;;; ====================
  61. ;;; Insertion sort, used to clean up the almost sorted results
  62. ;;; of quicksort.
  63.  
  64. (define (insertion-sort! v obj-<)
  65.   (loop (step j .in 1 to (vector-length v))
  66.     (bind (vj (vref v j)))
  67.     (do (loop (decr i in. j to 0)
  68.           (bind (vi (vref v i)))
  69.           (while (obj-< vj vi))
  70.           (do (set! (vref v (+ 1 i)) vi))
  71.           (result (set! (vref v (+ 1 i)) vj))))
  72.     (result v)))
  73.  
  74.  
  75. ;;; vector-remove-duplicates!
  76. ;;; ==============================
  77. ;;; Remove duplicates from a sorted vector.  The definition for
  78. ;;; vectors copies the non-duplicates to the front of the vector,
  79. ;;; and returns the number of non-duplicates.  This has a rather
  80. ;;; bogus definition for vectors, but what should it do?
  81. ;;; N.B. VECTOR ARG MUST BE SORTED.
  82.  
  83. (define (vector-remove-duplicates! sv obj-<)
  84.   (if (= (vector-length sv) 0) 0
  85.       (loop (initial (lui 0) (lu (vref sv 0))) ; lu is last uniq elt seen
  86.         (step i .in 1 to (vector-length sv))
  87.         (bind (svi (vref sv i)))
  88.         (when (obj-< lu svi)) ; New unique elt
  89.         (next (lui (+ lui 1))
  90.           (lu svi))
  91.         (do (set! (vref sv lui) lu))
  92.         (result (+ 1 lui)))))
  93.  
  94. ;;; vector-remove-duplicates
  95. ;;; ========================
  96. ;;; Non-destructive version of VECTOR-REMOVE-DUPLICATES.
  97. ;;; Makes 2 passes over the vector, the first to count the number of non-dups,
  98. ;;; and the the second to install them in the result vector.
  99. ;;; N.B. VECTOR ARG MUST BE SORTED.
  100.  
  101. (define (vector-remove-duplicates sv obj-<)
  102.   (if (= (vector-length sv) 0) (make-vector 0) ; special case 0-elt vecs
  103.       ;; First, find out how many unique elements there are...
  104.       (loop (initial (numelts 1) (lu (vref sv 0))) ; lu is last uniq elt seen
  105.         (step i .in 1 to (vector-length sv))
  106.         (bind (vi (vref sv i)))
  107.         (when (obj-< lu vi)) ; new unique elt
  108.         (next (numelts (+ numelts 1)) (lu vi))
  109.         ;; ...then, make the new vector, and stash the elements
  110.         (result 
  111.          (loop (initial (ans (make-vector numelts))
  112.                 (ui 0) ; unique count
  113.                 (lu (vref sv 0)))
  114.            (before (set! (vref ans 0) lu))
  115.            (step i .in 1 to (vector-length sv))
  116.            (bind (vi (vref sv i)))
  117.            (when (obj-< lu vi)) ; new unique elt
  118.            (next (ui (+ ui 1))
  119.              (lu vi))
  120.            (do (set! (vref ans ui) lu))
  121.            (result ans))))))
  122.  
  123. ;;; Heap sort. Heap sort is nice because:
  124. ;;; 1. It is stable (the order of = elts isn't altered)
  125. ;;; 2. Worst case is n log(n) (quicksort has n^2 worst case)
  126.  
  127. (define (heap-sort! v obj-<)
  128.   (let ((vlen (vector-length v)))
  129.     (if (> vlen 1) ; 0 & 1 elt vecs are already sorted.
  130.     (let ((heapify
  131.            (lambda (root end)
  132.          (let ((root-val (vref v root))
  133.                (leaf-bound (fixnum-ashr (- end 1) 1))) ;last non-lf
  134.            (iterate iter ((j root))
  135.              (if (< leaf-bound j)
  136.              (set! (vref v j) root-val)
  137.              (receive (son-ind son-val)
  138.                (let* ((i1 (+ (fixnum-ashl j 1) 1))
  139.                   (v1 (vref v i1))
  140.                   (i2 (+ i1 1)))
  141.                  (if (< end i2)
  142.                  (return i1 v1)
  143.                  (let ((v2 (vref v i2)))
  144.                    (if (obj-< v2 v1) ; prefer right son
  145.                        (return i1 v1); if tie for stability
  146.                        (return i2 v2)))))
  147.                (cond ((obj-< root-val son-val)
  148.                   (set! (vref v j) son-val)
  149.                   (iter son-ind))
  150.                  (else
  151.                   (set! (vref v j) root-val))))))))))
  152.  
  153.  
  154.       ;; Put the vector into heap order
  155.       (let ((end (- vlen 1)))
  156.         (loop (decr i .in. (fixnum-ashr (- end 1) 1) to 0)
  157.           (do (heapify i end))))
  158.       ;; Pull out the elements in decreasing order.
  159.       (loop (decr i in vlen to 0)
  160.         (do (set! (vref v i) (swap (vref v 0) (vref v i)))
  161.             (heapify 0 (- i 1)))))))
  162.   v)
  163.  
  164.  
  165.